home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / 1svga.zip / GR_DEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-07  |  11KB  |  369 lines
  1. {┌────────────────────────────────────────────╖
  2.  │   ▄▄▄▄▄  ▄▄▄▄▄                             ║
  3.  │  █▒      █▒   █▒  SVGA/VESA Graph Demo     ║
  4.  │  █▒  ▀█▒ █▒▄▄▄▀   640x480--1024x768 256C   ║
  5.  │  █▒   █▒ █▒   █▒  Written by Jou-Nan Chen  ║
  6.  │   ▀▀▀▀   ▀    ▀                            ║
  7.  ╘════════════════════════════════════════════╝}
  8.  
  9. uses Crt,Graph,Txt;
  10.  
  11. const Name:array[0..9] of string[8]=(
  12.     'Line1','Line2' ,'Line3' ,'Line4', 'Line5',
  13.     'Rose' ,'Dough1','Dough2','Mirror','Flowers');
  14. var Ratio:real;    { 1=640, 1.25=800, 1.6=1024 }
  15.     Pal:array[0..767] of byte;
  16.  
  17. { ─────────────── Graph1 ─────────────── }
  18. procedure Graph1(Xc,Yc,Xr,Yr:integer);
  19. var X0,Y0,X1,Y1,I,X,Y:integer;
  20.     A,M:real;
  21. begin
  22.   A:=0; X:=Trunc(Xr*0.4); Y:=Trunc(Yr*0.4);
  23.   for I:=0 to 800 do begin
  24.     X0:=Xc+Trunc(Xr*Cos(A));
  25.     Y0:=Yc+Trunc(Yr*Sin(5*A)*Cos(A/1.5));
  26.     M:=Sin(A);
  27.     X1:=Trunc(X*M);
  28.     Y1:=Trunc(Y*M);
  29.     SetColor(I div 12+32);
  30.     Line(X0,Y0,X0+X1,Y0+Y1);
  31.     Line(X0,Y0,X0+X1,Y0-Y1);
  32.     A:=A+Pi/400;
  33.   end;
  34. end;
  35. { ─────────────── Graph2 ─────────────── }
  36. procedure Graph2(Xc,Yc,Xr,Yr:integer);
  37. var X1,Y1,X2,Y2,I:integer;
  38.     A,M,N:real;
  39. begin
  40.   A:=0;
  41.   for I:=0 to 500 do begin
  42.     M:=Sin(A); N:=Cos(A);
  43.     X1:=Xc+Trunc(1.2*(Xr+Xr/3*(1+0.5*Cos(12*A))*N)*N);
  44.     X2:=Xc+Trunc(1.2*(Yr+Yr/3*(1+0.5*Sin(12*A))*N)*N);
  45.     Y1:=Yc-Trunc((Xr+Xr/3*(1+0.5*Cos(10*A))*M)*M);
  46.     Y2:=Yc-Trunc((Yr+Yr/2*(1+0.5*Cos(15*A))*M)*M);
  47.     SetColor(I div 7+32);
  48.     Line(X1,Y1,X2,Y2);
  49.     A:=A+Pi/250;
  50.   end;
  51. end;
  52. { ─────────────── Graph3 ─────────────── }
  53. procedure Graph3(Xc,Yc,R:integer);
  54. var X1,Y1,X2,Y2,I:integer;
  55.     A,F:real;
  56. begin
  57.   A:=0;
  58.   for I:=0 to 1600 do begin
  59.     F:=R*(1+0.25*Cos(20*A))*(1+Sin(4*A));
  60.     X1:=Xc+Trunc(F*Cos(A));
  61.     X2:=Xc+Trunc(F*Cos(A+Pi/5));
  62.     Y1:=Yc-Trunc(F*Sin(A));
  63.     Y2:=Yc-Trunc(F*Sin(A+Pi/5));
  64.     SetColor(I div 23+32);
  65.     Line(X1,Y1,X2,Y2);
  66.     A:=A+Pi/800;
  67.   end;
  68. end;
  69. { ─────────────── Graph4 ─────────────── }
  70. procedure Graph4(Xc,Yc,R:integer);
  71. var X1,Y1,X2,Y2,I:integer;
  72.     A,F:real;
  73. begin
  74.   A:=0;
  75.   for I:=0 to 1600 do begin
  76.     F:=R*(1+0.25*Cos(4*A))*(1+Sin(8*A));
  77.     X1:=Xc+Trunc(F*Cos(A));
  78.     X2:=Xc+Trunc(F*Cos(A+Pi/8));
  79.     Y1:=Yc-Trunc(F*Sin(A));
  80.     Y2:=Yc-Trunc(F*Sin(A+Pi/8));
  81.     SetColor(I div 23+32);
  82.     Line(X1,Y1,X2,Y2);
  83.     A:=A+Pi/800;
  84.   end;
  85. end;
  86. { ─────────────── Graph5 ─────────────── }
  87. procedure Graph5(Xc,Yc,R:integer);
  88. var X1,Y1,X2,Y2,I:integer;
  89.     A,E:real;
  90. begin
  91.   A:=0;
  92.   for I:=0 to 800 do begin
  93.     E:=R*(1+0.5*Sin(2.5*A));
  94.     X1:=Xc+Trunc(E*Cos(A));
  95.     X2:=Xc+Trunc(E*Cos(A+Pi/4));
  96.     Y1:=Yc-Trunc(E*Sin(A));
  97.     Y2:=Yc-Trunc(E*Sin(A+Pi/4));
  98.     SetColor(I div 12+32);
  99.     Line(X1,Y1,X2,Y2);
  100.     A:=A+Pi/200;
  101.   end;
  102. end;
  103. { ─────────────── Graph6 ─────────────── }
  104. procedure Graph6(Xi,Yi,R,Xr,Yr:integer);
  105. var X,Y,N,P,K,I,Bx,By:integer;
  106.     A,E:real;
  107. begin
  108.   for N:=2 to 7 do
  109.     for P:=1 to 6 do begin
  110.       if N mod 2=0 then K:=2 else K:=1;
  111.       A:=0; SetColor(6*N+P+48);
  112.       for I:=0 to 15*N*K do begin
  113.     E:=R/5*Sin(N*P*A)+R*Sin(N*A);
  114.     X:=Xr*(N-2)+Xi+Trunc(E*Cos(A));
  115.     Y:=Yr*(P-1)+Yi+Trunc(E*Sin(A));
  116.     if I=0 then begin MoveTo(X,Y); Bx:=X; By:=Y; end;
  117.     LineTo(X,Y);
  118.     A:=A+Pi/15/N;
  119.       end;
  120.       LineTo(Bx,By);
  121.     end;
  122. end;
  123. { ─────────────── Graph7 ─────────────── }
  124. procedure Graph7(Xc,Yc,R:integer);
  125. var XX,YY:array[1..120] of integer;
  126.     X,Px,Py,Bx,By,X1,Y1,X2,Y2,I:integer;
  127.     Th,A:real;
  128. begin
  129.   A:=0; X:=4*R;
  130.   for I:=1 to 120 do begin
  131.     Th:=66*Sqrt(Abs(Cos(3*A)))+12*Sqrt(Abs(Cos(9*A)));
  132.     XX[I]:=Trunc(Th*Cos(A)*1.2/320*R);
  133.     YY[I]:=Trunc(Th*Sin(A)/320*R);
  134.     A:=A+Pi/60;
  135.   end;
  136.   for Py:=1 to 2 do
  137.     for Px:=1 to 8 do begin
  138.       for I:=1 to 120 do begin
  139.     X1:=XX[I]+Px*R shr 1-R shr 2;
  140.     Y1:=YY[I]+Py*R shr 1-R shr 2;
  141.     Th:=2*Pi*(X-X1)/X;
  142.     X2:=Xc+Trunc(Y1*Cos(Th));
  143.     Y2:=Yc+Trunc(Y1*Sin(Th));
  144.     if I=1 then begin MoveTo(X2,Y2); Bx:=X2; By:=Y2; end;
  145.     SetColor((120*(2*Py+Px)+I) div 22+32);
  146.     LineTo(X2,Y2);
  147.       end;
  148.       LineTo(Bx,By);
  149.     end;
  150. end;
  151. { ─────────────── Graph8 ─────────────── }
  152. procedure Graph8(Xc,Yc,R:integer);
  153. var XX,YY:array[1..120] of integer;
  154.     X,Px,Py,Bx,By,X1,Y1,X2,Y2,I:integer;
  155.     Th,A,M,N:real;
  156. begin
  157.   A:=0; X:=4*R;
  158.   for I:=1 to 120 do begin
  159.     Th:=40*Sin(4*(A+Pi/8));
  160.     M:=Sin(A); N:=Cos(A);
  161.     XX[I]:=Trunc((Th*N+45*N*N*N)/320*R);
  162.     YY[I]:=Trunc((Th*M+45*M*M*M)/320*R);
  163.     A:=A+Pi/60;
  164.   end;
  165.   for Py:=1 to 2 do
  166.     for Px:=1 to 8 do begin
  167.       for I:=1 to 120 do begin
  168.     X1:=XX[I]+Px*R shr 1-R shr 2;
  169.     Y1:=YY[I]+Py*R shr 1-R shr 2;
  170.     Th:=2*Pi*(X-X1)/X;
  171.     X2:=Xc+Trunc(Y1*Cos(Th));
  172.     Y2:=Yc+Trunc(Y1*Sin(Th));
  173.     if I=1 then begin MoveTo(X2,Y2); Bx:=X2; By:=Y2; end;
  174.     SetColor((120*(2*Py+Px)+I) div 22+32);
  175.     LineTo(X2,Y2);
  176.       end;
  177.       LineTo(Bx,By);
  178.     end;
  179. end;
  180. { ─────────────── Graph9 ─────────────── }
  181. procedure Graph9(Xc,Yc,D,R:integer);
  182. var XX,YY:array[1..120] of integer;
  183.     D2,Un,Uv,K,S,X,Y,Px,Py,Bx,By,I,Sq:longint;
  184.     Th,Sc,A,M:real;
  185. begin
  186.   A:=0; Un:=12; Uv:=D div Un; K:=Uv div 2; Sc:=Uv/100; D2:=D shr 1;
  187.   for I:=1 to 120 do begin
  188.     Th:=90*(0.8+0.2*Sin(12*A))*(0.5+0.5*Sin(4*A));
  189.     XX[I]:=Trunc(Th*Cos(A));
  190.     YY[I]:=Trunc(Th*Sin(A));
  191.     A:=A+Pi/60;
  192.   end;
  193.   for Px:=1 to Un do
  194.     for Py:=1 to Un do begin
  195.       for I:=1 to 120 do begin
  196.     X:=Trunc(XX[I]*Sc)+Px*Uv-D2-K;
  197.     Y:=Trunc(YY[I]*Sc)+Py*Uv-D2-K;
  198.     Sq:=X*X+Y*Y;
  199.     if Sq<R*R then begin
  200.       if X<0 then S:=-1 else S:=1;
  201.       Th:=ArcTan(Y/(X+0.1));
  202.       M:=R*Sin(2*ArcTan(Sqrt(Sq)/R));
  203.       X:=S*Trunc(M*Cos(Th));
  204.       Y:=S*Trunc(M*Sin(Th));
  205.     end;
  206.     X:=X*23 div 15+Xc; Y:=Y*23 div 15+Yc;
  207.     if I=1 then begin MoveTo(X,Y); Bx:=X; By:=Y; end;
  208.     SetColor((120*(Px+Py)+I) div 42+32);
  209.     LineTo(X,Y);
  210.       end;
  211.       LineTo(Bx,By);
  212.     end;
  213. end;
  214. { ─────────────── Graph10 ─────────────── }
  215. procedure Graph10(Xc,Yc:integer;Rr:real);
  216. const Data:array[1..9] of integer=(7,436,245,17,775,180,31,1020,130);
  217. var Ste,Re,K,S,X,Y,Px,Py,Bx,By,I:integer;
  218.     A,AA,Ls,Di,R:real;
  219. begin
  220.   Px:=Xc; Py:=Yc; R:=50*Rr;
  221.   S:=8-Random(5);
  222.   if S mod 2=0 then K:=2 else K:=1;
  223.   A:=0; SetColor(32);
  224.   while A<=K*Pi+Pi/10/S do begin
  225.     X:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Cos(A))+Px;
  226.     Y:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Sin(A))+Py;
  227.     if A=0 then MoveTo(X,Y);
  228.     LineTo(X,Y);
  229.     A:=A+Pi/8/S;
  230.   end;
  231.   I:=0;
  232.   for Re:=1 to 3 do begin
  233.     Ste:=Data[3*Re-2]; Di:=Data[3*Re-1]/6*Rr; R:=Data[3*Re]/6*Rr;
  234.     if Re=2 then Ls:=(2*Pi/Ste)-0.1 else Ls:=0;
  235.     AA:=0;
  236.     while AA<=2*Pi-Ls do begin
  237.       Px:=Xc+Trunc(Di*Cos(AA));
  238.       Py:=Yc+Trunc(Di*Sin(AA));
  239.       S:=8-Random(5);
  240.       if S mod 2=0 then K:=2 else K:=1;
  241.       A:=0;
  242.       SetColor(I+33);
  243.       while A<=K*Pi+Pi/10/S do begin
  244.     X:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Cos(A))+Px;
  245.     Y:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Sin(A))+Py;
  246.     if A=0 then MoveTo(X,Y);
  247.     LineTo(X,Y);
  248.     A:=A+Pi/8/S;
  249.       end;
  250.       AA:=AA+2*Pi/Ste; I:=I+1;
  251.     end;
  252.   end;
  253.   A:=0; I:=0;
  254.   while A<=14*Pi do begin
  255.     X:=Xc+Trunc(Trunc(250*Rr)*(1+1/5*Sin(9.06*A))*Cos(A));
  256.     Y:=Yc+Trunc(Trunc(250*Rr)*(1+1/5*Sin(9.06*A))*Sin(A));
  257.     if A=0 then MoveTo(X,Y);
  258.     SetColor(I mod 72+32); LineTo(X,Y);
  259.     A:=A+Pi/60; I:=I+1;
  260.   end;
  261. end;
  262. { ─────────────── Ratio(Number) ─────────────── }
  263. function R(Num:integer):integer;
  264. begin
  265.   R:=Trunc(Num*Ratio);
  266. end;
  267. { ─────────────── Print ─────────────── }
  268. procedure Print(X,Y,Color,BkColor:integer;St:string);
  269. begin
  270.   Dec(Y,R(6));
  271.   SetColor(BkColor);
  272.   OutTextXY(X+1,Y+1,St);
  273.   SetColor(Color);
  274.   OutTextXY(X,Y,St);
  275.   OutTextXY(X+1,Y,St);
  276. end;
  277. { ─────────────── Screen ─────────────── }
  278. procedure Screen;
  279. const St:array[0..7] of string[24]=(
  280.     'SVGA/VESA 256 Colors','Graph Demo',
  281.     'Designed by Jou-Nan Chen','Rewritten in 1994',
  282.     'Arrow keys to select','Enter to show graph',
  283.     '* key to colorize','Esc to quit graph demo');
  284. var I:integer;
  285. begin
  286.   SetFillStyle(1,1);
  287.   Bar(0,R(400),R(640)-1,R(480)-1);
  288.   SetColor(11);
  289.   Rectangle(1,R(400)+1,R(640)-2,R(480)-2);
  290.   SetTextStyle(5,0,4);
  291.   SetUserCharSize(R(4),4,R(4),4);
  292.   for I:=0 to 7 do
  293.     Print(R(40),R(20)